C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.3
C---------------------------------------------------------
C ======================================================================
C
C       I S T P F   -   Main program for Toolpack/1 PFORT-77
C
C       Programmed by: Malcolm Cohen, NAG Central Office, 1986.
C
C ======================================================================
C
C       Basic Program Structure:
C       ------------------------
C
C                            +-------+
C                            | ISTPF |
C                            +---+---+
C                                |
C     +---------------+----------+------+------------+------------+
C     |               |                 |            |            |
C     |          +PFLIB1.MAC+       PFLIB2.MAC   PFLIB3.MAC   PFLIB4.MAC
C     |          |          |           |            |            |
C +---+----+ +---+----+ +---+----+  +---+----+   +---+----+   +---+----+
C | PFARGS | | PFINIT | | PFCHKL |  | PFREAD |   | PFCONS |   | PFCHKS |
C +--------+ +--------+ +--------+  +---+----+   +---+----+   +---+----+
C                           |           |            |            |
C                          ...         ...          ...          ...
C                          ------low-level processing routines------
C
C Thus, we note: (1) All PFORT-77 checking is done in PFLIB1-4, each of
C                    which contains the code for one phase of PFORT-77.
C                (2) The interface to the checking routines is:
C                       PFINIT - must be called first.
C                       PFCHKL - performs local checking.
C                       PFREAD - read PFORT77 data from attribute area,
C                                this must be done for each attribute
C                                file to be processed.
C                       PFCONS - construct PFORT77 data structures,
C                                this must be done after all attribute
C                                information has been read in.
C                       PFCHKS - check the program representation,
C                                this must be done at the end.
C                (3) An error found in one phase will generally preclude
C                    successful operation of following phases.
C
 
        PROGRAM ISTPF
 
        CHARACTER*(*) ABTMES
        PARAMETER (ABTMES='ISTPF aborted...')
 
        INTEGER TREPTH(81),SYMPTH(81),ATRPTH(81),
     +          LIBPTH(81),IODREF,IODTRE,IODSYM,IODATR,IODLIB,
     +          NERROR,NWARN,STATUS,I
        LOGICAL REFFIL
 
        INTEGER GETARG,OPEN,LENGTH,ZGTCMD
        EXTERNAL ZINIT,GETARG,ZQUIT,ZYINPT,ZYINSY,CLOSE,OPEN,REMARK,
     +           ZMESS,ZYXRAB,ERROR,CANT,ZPTINT,ZCHOUT,LENGTH
 
        CALL ZINIT
 
        CALL ZMESS('ISTPF - Toolpack/1 PFORT-77 Portability Verifier',
     +             1)
 
        IF (GETARG(1,TREPTH,81).EQ.-100) CALL PFARGS(TREPTH,1)
 
        NERROR=0
        NWARN=0
 
        REFFIL=TREPTH(1).EQ.40
        IF (REFFIL) THEN
            TREPTH(LENGTH(TREPTH))=129
            IODREF=OPEN(TREPTH(2),0)
            IF (IODREF.EQ.-1) THEN
                CALL CANT(TREPTH(2))
                CALL ERROR(ABTMES)
            END IF
            IF (IODREF.EQ.0) THEN
                CALL ZMESS('Input filenames, end with bl'//'ank line',
     +                     1)
                CALL PFARGS(TREPTH,1)
                CALL PFARGS(SYMPTH,2)
                CALL PFARGS(ATRPTH,3)
            ELSE
                IF (ZGTCMD(TREPTH,IODREF).LE.0)
     +              CALL ERROR('Can''t re'//'ad reference file')
                IF (ZGTCMD(SYMPTH,IODREF).LE.0)
     +              CALL ERROR('Can''t re'//'ad reference file')
                IF (ZGTCMD(ATRPTH,IODREF).LE.0)
     +              CALL ERROR('Can''t re'//'ad reference file')
            END IF
        ELSE
            IF (GETARG(2,SYMPTH,81).EQ.-100) CALL PFARGS(SYMPTH,2)
            IF (GETARG(3,ATRPTH,81).EQ.-100) CALL PFARGS(ATRPTH,3)
        END IF
        CALL PFINIT
 100    IF (TREPTH(1).NE.129) THEN
            IODTRE=OPEN(TREPTH,0)
            IF (IODTRE.EQ.-1) THEN
                CALL CANT(TREPTH)
                CALL ERROR(ABTMES)
            END IF
            IODSYM=OPEN(SYMPTH,0)
            IF (IODSYM.EQ.-1) THEN
               CALL CANT(SYMPTH)
               CALL ERROR(ABTMES)
            END IF
            IODATR=OPEN(ATRPTH,0)
            IF (IODATR.EQ.-1) THEN
                CALL CANT(ATRPTH)
                CALL ERROR(ABTMES)
            END IF
            CALL ZYINPT(IODTRE)
            CALL CLOSE(IODTRE)
            CALL ZYINSY(IODSYM)
            CALL CLOSE(IODSYM)
            CALL ZYXRAB(IODATR)
            CALL CLOSE(IODATR)
            CALL PFCHKL(NERROR,NWARN)
            CALL PFREAD
            IF (REFFIL) THEN
                IF (IODREF.EQ.0) THEN
                    CALL PFARGS(TREPTH,1)
                    IF (TREPTH(1).NE.129) THEN
                        CALL PFARGS(SYMPTH,2)
                        CALL PFARGS(ATRPTH,3)
                        GOTO 100
                    END IF
                ELSE IF (ZGTCMD(TREPTH,IODREF).GT.0) THEN
                    IF (ZGTCMD(SYMPTH,IODREF).LE.0)
     +                  CALL ERROR('Error in reference file')
                    IF (ZGTCMD(ATRPTH,IODREF).LE.0)
     +                  CALL ERROR('Error in reference file')
                    GOTO 100
                END IF
            END IF
        END IF
 
        IF (NERROR.GT.0) CALL REMARK(
     +'Program has errors - proceeding with global analysis')
        CALL CLOSE(IODREF)
 
        I=4
        LIBPTH(2)=129
 200    IF (GETARG(I,LIBPTH,81).NE.-100) THEN
            IF (LIBPTH(1).NE.45 .OR. LIBPTH(2).NE.129) THEN
                IF (LIBPTH(1).NE.40) THEN
                    IODLIB=OPEN(LIBPTH,0)
                    IF (IODLIB.EQ.-1) THEN
                        CALL CANT(LIBPTH)
                        CALL ERROR('ISTPF aborted...')
                    END IF
                    CALL ZYXRAB(IODLIB)
                    CALL CLOSE(IODLIB)
                    CALL PFREAD
                ELSE
                    LIBPTH(LENGTH(LIBPTH)) = 129
                    IODREF=OPEN(LIBPTH(2),0)
                    IF (IODREF.EQ.-1) THEN
                        CALL CANT(LIBPTH(2))
                        CALL ERROR('ISTPF aborted...')
                    ENDIF
 250                IF (ZGTCMD(LIBPTH,IODREF).GT.0) THEN
                        IODLIB=OPEN(LIBPTH,0)
                        IF (IODLIB.EQ.-1) THEN
                            CALL CANT(LIBPTH)
                        ELSE
                            CALL ZYXRAB(IODLIB)
                            CALL CLOSE(IODLIB)
                            CALL PFREAD
                        END IF
                        GOTO 250
                    END IF
                    CALL CLOSE(IODREF)
                END IF
                I=I+1
                IF (I.LE.10) GOTO 200
            END IF
        ELSE IF (I.EQ.4) THEN
            CALL ZMESS('Input library files, end with bl'//'ank line',
     +                 1)
 300        CALL PFARGS(LIBPTH,4)
            IF (LIBPTH(1).NE.129) THEN
                IF(LIBPTH(1).NE.40) THEN
                    IODLIB=OPEN(LIBPTH,0)
                    IF (IODLIB.EQ.-1) THEN
                        CALL CANT(LIBPTH)
                    ELSE
                        CALL ZYXRAB(IODLIB)
                        CALL CLOSE(IODLIB)
                        CALL PFREAD
                    END IF
                ELSE
                    LIBPTH(LENGTH(LIBPTH)) = 129
                    IODREF=OPEN(LIBPTH(2),0)
                    IF (IODREF.EQ.-1) THEN
                        CALL CANT(LIBPTH)
                        CALL ERROR('ISTPF aborted...')
                    ENDIF
 350                IF (ZGTCMD(LIBPTH,IODREF).GT.0) THEN
                        IODLIB=OPEN(LIBPTH,0)
                        IF (IODLIB.EQ.-1) THEN
                            CALL CANT(LIBPTH)
                        ELSE
                            CALL ZYXRAB(IODLIB)
                            CALL CLOSE(IODLIB)
                            CALL PFREAD
                        END IF
                        GOTO 350
                    END IF
                    CALL CLOSE(IODREF)
                END IF
                GOTO 300
            END IF
        END IF
 
        CALL PFCONS
        CALL PFCHKS(NERROR,NWARN)
 
        IF (NERROR.GT.0) THEN
            CALL ZCHOUT('[ISTPF Terminated, ',2)
            CALL ZPTINT(NERROR,1,2)
            IF (NERROR.EQ.1) THEN
                CALL ZCHOUT(' er'//'ror o'//'r unsafe reference',2)
            ELSE
                CALL ZCHOUT(' errors o'//'r unsafe references',2)
            END IF
            CALL ZMESS(' detected]',2)
            CALL ZQUIT(-1)
        ELSE IF (NWARN.GT.0) THEN
            CALL ZMESS('[ISTPF Terminated, Warnings produced]',2)
            CALL ZQUIT(-1002)
        ELSE
            CALL ZMESS('[ISTPF Normal Termination]',2)
            CALL ZQUIT(-2)
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       P F A R G S   -   Prompt user for arguments to PF tool
C
 
        SUBROUTINE PFARGS(PATH,NUMBER)
        INTEGER PATH(*),NUMBER
 
        INTEGER PROMPT(25,4),I
 
        SAVE PROMPT
 
        INTEGER ZGTCMD
        EXTERNAL ZGTCMD,ZPRMPT,ERROR
 
C "Input parse tree: "
C "Input symbol table: "
C "Attribute file: "
C "Library attribute file: "
 
        DATA (PROMPT(I,1),I=1,19)/73,110,112,117,116,32,112,
     +97,114,115,101,32,116,114,101,101,58,32,129/,
     +       (PROMPT(I,2),I=1,21)/73,110,112,117,116,32,115,
     +121,109,98,111,108,32,116,97,98,108,101,58,
     +32,129/,
     +       (PROMPT(I,3),I=1,17)/65,116,116,114,105,98,117,
     +116,101,32,102,105,108,101,58,32,129/,
     +       (PROMPT(I,4),I=1,25)/76,105,98,114,97,114,121,
     +32,97,116,116,114,105,98,117,116,101,32,102,
     +105,108,101,58,32,129/
 
        CALL ZPRMPT(PROMPT(1,NUMBER))
        IF (ZGTCMD(PATH,0).EQ.-1)
     +      CALL ERROR('ZGTCMD returned Error status')
 
        END
